home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
TeX 1995 July
/
TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO
/
macros
/
latex209
/
contrib
/
slatex
/
defrecor.ss
< prev
next >
Wrap
Text File
|
1993-11-07
|
4KB
|
123 lines
;defrecor.ss
;enums, records, setf
;(c) Dorai Sitaram, December 1991, Rice University
;defenum
'(enable chez scmx)
(extend-syntax (defenum)
;(defenum x ...) defines x ... to be distinct objects that can
;be used as a (C-like) enumerated datatype
((defenum (1) () n ((x i) ...))
(begin (define x (integer->char i)) ...))
((defenum (1) (x . more-x) i x-i-pairs)
(defenum (1) more-x (+ i 1) ((x i) . x-i-pairs)))
((defenum . xs)
(defenum (1) xs 0 ())))
'(enable cl)
(define-macro! defenum z
;(let loop ...) doesn't work in macro transformer, hence the do
(do ((z z (cdr z))
(n 0 (+ n 1))
(r '() (cons `(define ,(car z) (integer->char ,n)) r)))
((null? z) `(begin ,@r))))
'(disable chez cl scmx)
(define-macro! defenum z
(let loop ((z z) (n 0) (r '()))
(if (null? z) `(begin ,@r)
(loop (cdr z) (+ n 1)
(cons `(define ,(car z) (integer->char ,n)) r)))))
;defrecord
'(enable chez scmx)
(extend-syntax (defrecord)
;(defrecord n f ...) defines a thunk n that creates a record
;with fields f ...
((defrecord (1) name () n ((f i) ...))
(begin (define name (lambda () (make-vector n)))
(define f i) ...))
((defrecord (1) name (f . more-f) i f-i-pairs)
(defrecord (1) name more-f (+ i 1) ((f i) . f-i-pairs)))
((defrecord name . fields)
(defrecord (1) name fields 0 ())))
'(enable cl)
(define-macro! defrecord (name . fields)
(do ((fields fields (cdr fields))
(i 0 (+ i 1))
(r '() (cons `(define ,(car fields) ,i) r)))
((null? fields)
`(begin (define ,name (lambda () (make-vector ,i)))
,@r))))
'(disable chez cl scmx)
(define-macro! defrecord (name . fields)
(let loop ((fields fields) (i 0) (r '()))
(if (null? fields)
`(begin (define ,name (lambda () (make-vector ,i)))
,@r)
(loop (cdr fields) (+ i 1)
(cons `(define ,(car fields) ,i) r)))))
;of
'(enable chez scmx)
(extend-syntax (of /)
;of is used to access record fields
((of s i) (vector-ref s i))
((of s / i) (string-ref s i))
((of s i . z) (of (vector-ref s i) . z)))
'(disable chez scmx)
(define-macro! of (r i . z)
(cond ((null? z) `(vector-ref ,r ,i))
((and (eq? i '/) (= (length z) 1))
`(string-ref ,r ,(car z)))
(else `(of (vector-ref ,r ,i) ,@z))))
;setf
'(enable cl)
(begin
(defsetf list-ref list-set!)
(defsetf string-ref string-set!)
(defsetf vector-ref vector-set!))
'(enable chez scmx)
(extend-syntax (setf list-ref string-ref vector-ref of)
((setf (list-ref l i) r) (list-set! l i r))
((setf (string-ref s i) r) (string-set! s i r))
((setf (vector-ref v i) r) (vector-set! v i r))
((setf (of z ...) r) (the-setter-for-of z ... r))
((setf l r) (set! l r)))
'(disable chez cl scmx)
(define-macro! setf (l r)
(if (symbol? l) `(set! ,l ,r)
(let ((a (car l)))
`(,(cond ((eq? a 'list-ref) 'list-set!)
((eq? a 'string-ref) 'string-set!)
((eq? a 'vector-ref) 'vector-set!)
((eq? a 'of) 'the-setter-for-of)
(else (lerror 'setf)))
,@(cdr l) ,r))))
;the-setter-for-of
'(enable chez scmx)
(extend-syntax (the-setter-for-of)
((the-setter-for-of s i v) (vector-set! s i v))
((the-setter-for-of s / i v) (string-set! s i v))
((the-setter-for-of s i . z)
(the-setter-for-of (vector-ref s i) . z)))
'(disable chez cl scmx)
(define-macro! the-setter-for-of (r i j . z)
(cond ((null? z) `(vector-set! ,r ,i ,j))
((and (eq? i '/) (= (length z) 1))
`(string-set! ,r ,j ,(car z)))
(else `(the-setter-for-of (vector-ref ,r ,i) ,j ,@z))))